home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / appleEvents.tcl < prev    next >
Encoding:
Text File  |  1998-11-21  |  9.2 KB  |  322 lines  |  [TEXT/ALFA]
  1. # JEG - modernized
  2. # 
  3. # make alias list to pass to AEBuild
  4. proc makeAlis {name} {
  5.     return [aebuild::alis $name]
  6. }
  7.  
  8. # JEG - This is unused???
  9. proc makeFile {name} {
  10.     return [aebuild::alis $name]    
  11. }
  12.  
  13. ## 
  14.  # -------------------------------------------------------------------------
  15.  # 
  16.  # "makeAlises" --
  17.  # 
  18.  #  This proc has changed so it takes a list of items rather than an
  19.  #  unknown number of args 'args'.  If 'l' is a list you must call
  20.  #  this proc with 'makeAlises $l' rather than 'eval makeAlises $l'
  21.  #  as was previously required.
  22.  # -------------------------------------------------------------------------
  23.  ##
  24.  
  25. # JEG - modernized
  26. # 
  27. proc makeAlises {names} {
  28.     return [aebuild::list $names -as alis]
  29. }
  30.  
  31. ## 
  32.  # -------------------------------------------------------------------------
  33.  # 
  34.  # "handleReply" --
  35.  # 
  36.  #  Queued replies are passed through AEPrint and then to this routine.
  37.  #  
  38.  #  If you write your own handleReply procedure, register it to this
  39.  #  proc with:
  40.  #  
  41.  #    currentReplyHandler 'my-proc-name'
  42.  #    
  43.  #  Do this each time you send an event which may receive a reply.
  44.  #  There is no need to register your proc at startup or any such
  45.  #  'pre-registering'.  Just call the above proc _each_ time.
  46.  #  
  47.  #  You proc should take one parameter (the reply), and should
  48.  #  return '1' if it handled the reply, otherwise it can do/return
  49.  #  anything else (although hopefully not much if it didn't handle
  50.  #  anything).
  51.  #  
  52.  #  If your replies often time-out or have other problems such
  53.  #  that you don't handle them correctly, you may wish to register
  54.  #  your reply-handler with 'currentReplyHandler 'my-proc' 1' which
  55.  #  says 'only register if it's not already registered'.  Or you
  56.  #  may wish to remove duplicates from the list of handlers 
  57.  #  directly.
  58.  #    
  59.  # Results:
  60.  #  depends on what is registered
  61.  # 
  62.  # Side effects:
  63.  #  calls other procs.  Removes handler from queue if it handled
  64.  #  the reply.
  65.  # 
  66.  # --Version--Author------------------Changes-------------------------------
  67.  #    1.0     <darley@fas.harvard.edu> first one with hook handling
  68.  #    2.0     <darley@fas.harvard.edu> different mechanism to give priority
  69.  # -------------------------------------------------------------------------
  70.  ##
  71. proc handleReply {rep} {
  72.     global lastReply replyHandlers
  73.     set lastReply $rep
  74.     set i 0
  75.     foreach h $replyHandlers {
  76.     if {$h != ""} {
  77.         catch [list $h $rep] res
  78.         if {$res == 1} {
  79.         set replyHandlers [lreplace $replyHandlers $i $i]
  80.         return
  81.         }
  82.     }
  83.     incr i
  84.     }
  85.     message "Reply '$rep' not handled"
  86. }
  87.  
  88. ensureset replyHandlers ""
  89.  
  90. ## 
  91.  # -------------------------------------------------------------------------
  92.  # 
  93.  # "currentReplyHandler" --
  94.  # 
  95.  #  Add item to end of queue to receive replies, even if it is already
  96.  #  in the queue, unless we set 'nodups'
  97.  # -------------------------------------------------------------------------
  98.  ##
  99. proc currentReplyHandler {proc {nodups 0}} {
  100.     global replyHandlers
  101.     if {!$nodups || (![lcontains replyHandlers $proc])} {
  102.     lappend replyHandlers $proc
  103.     }    
  104. }
  105.  
  106. # JEG - only used by thinkMenu.tcl. Why is it here?
  107. # 
  108. # Return an object record specifying the desired think project file.
  109. proc fileObject {name} {
  110.     join [concat {obj\{want:type('SFIL'), from:'null'(), form:'name', seld:“} [file tail $name] {”\}}] ""
  111. }
  112.  
  113. proc sendOpenEvent {filler appname fname} {
  114.     if {$filler == "noReply"} {
  115.     AEBuild $appname aevt odoc "----" [makeAlis $fname]
  116.     } else {
  117.     AEBuild -r $appname aevt odoc "----" [makeAlis $fname]
  118.     }
  119. }
  120.  
  121.  
  122. # Send open folder event to Finder. Name must end in colon.
  123. proc openFolder {name} {
  124.     if {![regexp ":$" $name]} {
  125.     append name ":"
  126.     }
  127.     switchTo Finder
  128.     sendOpenEvent -r Finder $name
  129. }
  130.  
  131. proc launchDoc {name} {
  132.     set app [app::launchFore [getFileSig $name]]
  133.     sendOpenEvent -r [file tail $app] $name
  134. }
  135.  
  136. # Send multiple open events
  137. proc sendOpenEvents {appname args} {
  138.     AEBuild -r $appname aevt odoc "----" [makeAlises $args]
  139. }
  140.  
  141. proc openAndSendFile {sig} {
  142.     set fname [win::Current]
  143.     if {[winDirty]} {
  144.     if {[dialog::yesno "Save '$fname'?"]} {
  145.         save
  146.     }
  147.     }
  148.     
  149.     set name [file tail [app::launchFore $sig]]
  150.     sendOpenEvent noReply $name $fname
  151. }
  152.  
  153. #================================================================================
  154. # General Apple Event handling routines
  155. #
  156. # (written by Tom Pollard for use in the MacPerl package)
  157. #================================================================================
  158.  
  159. # Quit an application.
  160. proc sendQuitEvent {appname} {
  161.     AEBuild $appname "aevt" "quit" 
  162. }
  163.  
  164. # Close one of an application's windows, designated by number.
  165. proc sendCloseWinNum {appname num} {
  166.     AEBuild $appname "core" "clos" "----" [AEWinByPos $num]
  167. }
  168.  
  169. # Close one of an application's windows, designated by name.
  170. proc sendCloseWinName {appname name} {
  171.     AEBuild $appname "core" "clos" "----" [AEWinByName $name]
  172. }
  173.  
  174. # Obtain the number of lines in one of an application's
  175. # windows, designated by name.
  176. proc sendCountLines {appname name} {
  177.     set winObj [AEWinByName $name]
  178.     set res [AEBuild -r $appname "core" "cnte" "----" $winObj kocl type('clin')]    
  179.     if {[regexp {:(.*)\}} $res allofit nlines]} {
  180.     return $nlines
  181.     } else {
  182.     return 0
  183.     }
  184. }
  185.  
  186. # Get a selected range of lines from one of an application's
  187. # windows, designated by name.  If $last is missing, then a single
  188. # line is returned; if both $first and $last are missing, then
  189. # the complete window contents are returned.
  190. proc sendGetText {appname name {first {missing}} {last {missing}}} {
  191.     global ALPHA
  192.     set winObj [AEWinByName $name]
  193.     if {$first != "missing"} {
  194.     if {$last != "missing"} {
  195.         set rangDesc [AELineRange $first $last]
  196.     } else {
  197.         set rangDesc [AEAbsPos $first]
  198.     }
  199.     set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
  200.     } else {
  201.     set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
  202.     }
  203.     set res [AEBuild -r $appname "core" "getd" "----" $objDesc]
  204.     if {![regexp {“.*”} $res text]} { set text {} }
  205.     return [string trim $text {“”}]
  206. }
  207.  
  208. # Set a selected range of lines in one of an application's
  209. # windows, designated by name.  If $last is missing, then a single
  210. # line is changed; if both $first and $last are missing, then
  211. # the complete window contents are replaced by the new text.
  212. proc sendSetText {appname name text {first {missing}} {last {missing}}} {
  213.     set winObj [AEWinByName $name]
  214.     if {$first != "missing"} {
  215.     if {$last != "missing"} {
  216.         set rangDesc [AELineRange $first $last]
  217.     } else {
  218.         set rangDesc [AEAbsPos $first]
  219.     }
  220.     set objDesc "obj{want:type('clin'), from:$winObj, $rangDesc }"
  221.     } else {
  222.     set objDesc "obj{want:type('ctxt'), from:$winObj, form:'indx', seld:abso('all') }"
  223.     }
  224.     set res [AEBuild -r $appname "core" "setd" "----" $objDesc "data" [curlyq $text]]    
  225.     if {![regexp {“.*”} $res text]} { set text {} }
  226.     return [string trim $text {“”}]
  227. }
  228.  
  229. ################################################################################
  230. # Utility functions for constructing AppleEvent descriptors for AEBuild
  231. ################################################################################
  232.  
  233. # JEG - modernized
  234. #
  235. proc AEFilename {name} {
  236.     return [aebuild::filename $name]
  237. }
  238.  
  239. # JEG - modernized
  240. #
  241. proc AEWinByName {name} {
  242.     return [aebuild::winByName $name]
  243. }
  244.  
  245. # JEG - modernized
  246. #
  247. proc AEWinByPos {absPos} {
  248.     return [aebuild::winByPos $absPos]
  249. }
  250.  
  251. # JEG - modernized
  252. #
  253. proc AELineRange {absPos1 absPos2} {
  254.     return [aebuild::lineRange $absPos1 $absPos2]
  255. }
  256.  
  257. # JEG - modernized
  258. #
  259. proc AEAbsPos {posName} {
  260.     return [aebuild::absPos $posName]
  261. }
  262.  
  263. # JEG - modernized
  264. #
  265. proc AEName {name} {
  266.     return [aebuild::name $name]
  267. }
  268.  
  269. # JEG - modernized
  270. #
  271. proc curlyq {str} {
  272.     return [aebuild::TEXT $str]
  273. }
  274.  
  275. ################################################################################
  276. proc nullObject {}                     { return "'null'()" }
  277. proc objectType {type}                 { return "type($type)" }
  278. proc nameObject {type name from}     { return "obj \{form:name, want:[objectType $type], seld:$name, from:$from\}" }
  279. proc indexObject {type ind from}     { return "obj \{form:indx, want:[objectType $type], seld:$ind, from:$from\}" }
  280. proc propertyObject { prop object } { return "obj \{form:prop, want:[objectType prop], seld:[objectType $prop], from:$object\}" }
  281.  
  282. # JEG - unused?
  283. # 
  284. # 'process' must have single quotes
  285. proc buildMsgReply { process suite event args } { return [eval [list AEBuild -r $process $suite $event ] $args] }
  286.  
  287. # JEG - modernized
  288. #
  289. proc countObjects { process fromObject class } {
  290.     return [aebuild::result $process core cnte \
  291.       ---- $fromObject \
  292.       kocl [objectType $class] \
  293.       ]
  294. }
  295.  
  296. proc createThingAtEnd {process container class} {
  297.     set res [AEBuild -r $process core crel insh "insl \{kobj:$container\}" kocl "type($class)"]
  298. }
  299.  
  300.  
  301. proc getObjectData { process class name from } {
  302.     set res [AEBuild -r $process core getd ---- [nameObject $class "“$name”" $from] {rtyp{type:TEXT}}]
  303.     if {[regexp {“(.*)”} $res dummy mtch]} {
  304.     return $mtch
  305.     } else {
  306.     error "Bad count proc"
  307.     }
  308. }
  309.  
  310.  
  311. proc objectProperty { process property object } {
  312.     AEBuild -r $process core getd ---- [propertyObject $property $object]
  313. }
  314.  
  315. # Extract and return a path from a result.
  316. proc extractPath {res} {
  317.     if {[regexp {«(.*)»} $res dummy fss]} {
  318.     return [specToPathName $fss]
  319.     }
  320.     error "bad path $name"
  321. }    
  322.